home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpcsrc.lha / fpc / compiler / os2_targ.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  11KB  |  376 lines
  1. {
  2.     $Id: os2_targ.pas,v 1.1.1.1 1998/03/25 11:18:15 root Exp $
  3.     Copyright (c) 1993-98 by Daniel Mantione
  4.     Portions Copyright (c) 1992-96 Eberhard Mattes
  5.  
  6.     Unit to write out import libraries and def files for OS/2
  7.  
  8.     This program is free software; you can redistribute it and/or modify
  9.     it under the terms of the GNU General Public License as published by
  10.     the Free Software Foundation; either version 2 of the License, or
  11.     (at your option) any later version.
  12.  
  13.     This program is distributed in the hope that it will be useful,
  14.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  15.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16.     GNU General Public License for more details.
  17.  
  18.     You should have received a copy of the GNU General Public License
  19.     along with this program; if not, write to the Free Software
  20.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22.  ****************************************************************************
  23. }
  24. {
  25.    A lot of code in this unit has been ported from C to Pascal from the
  26.    emximp utility, part of the EMX development system. Emximp is copyrighted
  27.    by Eberhard Mattes. Note: Eberhard doesn't know much about the Pascal
  28.    port, please send questions to Daniel Mantione
  29.    <d.s.p.mantione@twi.tudelft.nl>.
  30. }
  31. unit os2_targ;
  32.  
  33. interface
  34.  
  35. uses import;
  36.  
  37. type
  38.   pimportlibos2=^timportlibos2;
  39.   timportlibos2=object(timportlib)
  40.     procedure preparelib(const s:string);virtual;
  41.     procedure importprocedure(const func,module:string;index:longint;const name:string);virtual;
  42.     procedure generatelib;virtual;
  43.   end;
  44.  
  45. procedure write_def_file;
  46.  
  47. {***************************************************************************}
  48.  
  49. {***************************************************************************}
  50.  
  51. implementation
  52.  
  53. uses    dos,strings,globals,link,files;
  54.  
  55. const   profile_flag:boolean=false;
  56.  
  57. const   n_ext   = 1;
  58.         n_abs   = 2;
  59.         n_text  = 4;
  60.         n_data  = 6;
  61.         n_bss   = 8;
  62.         n_imp1  = $68;
  63.         n_imp2  = $6a;
  64.  
  65. type    reloc=packed record     {This is the layout of a relocation table
  66.                                  entry.}
  67.             address:longint;    {Fixup location}
  68.             remaining:longint;
  69.             {Meaning of bits for remaining:
  70.              0..23:              Symbol number or segment
  71.              24:                 Self-relative fixup if non-zero
  72.              25..26:             Fixup size (0: 1 byte, 1: 2, 2: 4 bytes)
  73.              27:                 Reference to symbol or segment
  74.              28..31              Not used}
  75.         end;
  76.  
  77.         nlist=packed record     {This is the layout of a symbol table entry.}
  78.             strofs:longint;     {Offset in string table}
  79.             typ:byte;           {Type of the symbol}
  80.             other:byte;         {Other information}
  81.             desc:word;          {More information}
  82.             value:longint;      {Value (address)}
  83.         end;
  84.  
  85.         a_out_header=packed record
  86.             magic:word;         {Magic word, must be $0107}
  87.             machtype:byte;      {Machine type}
  88.             flags:byte;         {Flags}
  89.             text_size:longint;  {Length of text, in bytes}
  90.             data_size:longint;  {Length of initialized data, in bytes}
  91.             bss_size:longint;   {Length of uninitialized data, in bytes}
  92.             sym_size:longint;   {Length of symbol table, in bytes}
  93.             entry:longint;      {Start address (entry point)}
  94.             trsize:longint;     {Length of relocation info for text, bytes}
  95.             drsize:longint;     {Length of relocation info for data, bytes}
  96.         end;
  97.  
  98.         ar_hdr=packed record
  99.             ar_name:array[0..15] of char;
  100.             ar_date:array[0..11] of char;
  101.             ar_uid:array[0..5] of char;
  102.             ar_gid:array[0..5] of char;
  103.             ar_mode:array[0..7] of char;
  104.             ar_size:array[0..9] of char;
  105.             ar_fmag:array[0..1] of char;
  106.         end;
  107.  
  108. var aout_str_size:longint;
  109.     aout_str_tab:array[0..2047] of byte;
  110.     aout_sym_count:longint;
  111.     aout_sym_tab:array[0..5] of nlist;
  112.  
  113.     aout_text:array[0..63] of byte;
  114.     aout_text_size:longint;
  115.  
  116.     aout_treloc_tab:array[0..1] of reloc;
  117.     aout_treloc_count:longint;
  118.  
  119.     aout_size:longint;
  120.     seq_no:longint;
  121.  
  122.     ar_member_size:longint;
  123.  
  124.     out_file:file;
  125.  
  126. procedure write_ar(const name:string;size:longint);
  127.  
  128. var ar:ar_hdr;
  129.     time:datetime;
  130.     dummy:word;
  131.     numtime:longint;
  132.     tmp:string[19];
  133.  
  134.  
  135. begin
  136.     ar_member_size:=size;
  137.     fillchar(ar.ar_name,sizeof(ar.ar_name),' ');
  138.     move(name[1],ar.ar_name,length(name));
  139.     getdate(time.year,time.month,time.day,dummy);
  140.     gettime(time.hour,time.min,time.sec,dummy);
  141.     packtime(time,numtime);
  142.     str(numtime,tmp);
  143.     fillchar(ar.ar_date,sizeof(ar.ar_date),' ');
  144.     move(tmp[1],ar.ar_date,length(tmp));
  145.     ar.ar_uid:='0     ';
  146.     ar.ar_gid:='0     ';
  147.     ar.ar_mode:='100666'#0#0;
  148.     str(size,tmp);
  149.     fillchar(ar.ar_size,sizeof(ar.ar_size),' ');
  150.     move(tmp[1],ar.ar_size,length(tmp));
  151.     ar.ar_fmag:='`'#10;
  152.     blockwrite(out_file,ar,sizeof(ar));
  153. end;
  154.  
  155. procedure finish_ar;
  156.  
  157. var a:byte;
  158.  
  159. begin
  160.     a:=0;
  161.     if odd(ar_member_size) then
  162.         blockwrite(out_file,a,1);
  163. end;
  164.  
  165. procedure aout_init;
  166.  
  167. begin
  168.   aout_str_size:=sizeof(longint);
  169.   aout_sym_count:=0;
  170.   aout_text_size:=0;
  171.   aout_treloc_count:=0;
  172. end;
  173.  
  174. function aout_sym(const name:string;typ,other:byte;desc:word;
  175.                   value:longint):longint;
  176.  
  177. begin
  178.     if aout_str_size+length(name)+1>sizeof(aout_str_tab) then
  179.         runerror($da);
  180.     if aout_sym_count>=sizeof(aout_sym_tab) div sizeof(aout_sym_tab[0]) then
  181.         runerror($da);
  182.     aout_sym_tab[aout_sym_count].strofs:=aout_str_size;
  183.     aout_sym_tab[aout_sym_count].typ:=typ;
  184.     aout_sym_tab[aout_sym_count].other:=other;
  185.     aout_sym_tab[aout_sym_count].desc:=desc;
  186.     aout_sym_tab[aout_sym_count].value:=value;
  187.     strPcopy(@aout_str_tab[aout_str_size],name);
  188.     aout_str_size:=aout_str_size+length(name)+1;
  189.     aout_sym:=aout_sym_count;
  190.     inc(aout_sym_count);
  191. end;
  192.  
  193. procedure aout_text_byte(b:byte);
  194.  
  195. begin
  196.     if aout_text_size>=sizeof(aout_text) then
  197.         runerror($da);
  198.     aout_text[aout_text_size]:=b;
  199.     inc(aout_text_size);
  200. end;
  201.  
  202. procedure aout_text_dword(d:longint);
  203.  
  204. type li_ar=array[0..3] of byte;
  205.  
  206. begin
  207.     aout_text_byte(li_ar(d)[0]);
  208.     aout_text_byte(li_ar(d)[1]);
  209.     aout_text_byte(li_ar(d)[2]);
  210.     aout_text_byte(li_ar(d)[3]);
  211. end;
  212.  
  213. procedure aout_treloc(address,symbolnum,pcrel,len,ext:longint);
  214.  
  215. begin
  216.     if aout_treloc_count>=sizeof(aout_treloc_tab) div sizeof(reloc) then
  217.         runerror($da);
  218.     aout_treloc_tab[aout_treloc_count].address:=address;
  219.     aout_treloc_tab[aout_treloc_count].remaining:=symbolnum+pcrel shl 24+
  220.      len shl 25+ext shl 27;
  221.     inc(aout_treloc_count);
  222. end;
  223.  
  224. procedure aout_finish;
  225.  
  226. begin
  227.     while (aout_text_size and 3)<>0 do
  228.         aout_text_byte ($90);
  229.     aout_size:=sizeof(a_out_header)+aout_text_size+aout_treloc_count*
  230.      sizeof(reloc)+aout_sym_count*sizeof(aout_sym_tab[0])+aout_str_size;
  231. end;
  232.  
  233. procedure aout_write;
  234.  
  235. var ao:a_out_header;
  236.  
  237. begin
  238.     ao.magic:=$0107;
  239.     ao.machtype:=0;
  240.     ao.flags:=0;
  241.     ao.text_size:=aout_text_size;
  242.     ao.data_size:=0;
  243.     ao.bss_size:=0;
  244.     ao.sym_size:=aout_sym_count*sizeof(aout_sym_tab[0]);
  245.     ao.entry:=0;
  246.     ao.trsize:=aout_treloc_count*sizeof(reloc);
  247.     ao.drsize:=0;
  248.     blockwrite(out_file,ao,sizeof(ao));
  249.     blockwrite(out_file,aout_text,aout_text_size);
  250.     blockwrite(out_file,aout_treloc_tab,sizeof(reloc)*aout_treloc_count);
  251.     blockwrite(out_file,aout_sym_tab,sizeof(aout_sym_tab[0])*aout_sym_count);
  252.     longint((@aout_str_tab)^):=aout_str_size;
  253.     blockwrite(out_file,aout_str_tab,aout_str_size);
  254. end;
  255.  
  256. procedure timportlibos2.preparelib(const s:string);
  257.  
  258. {This code triggers a lot of bugs in the compiler.
  259. const   armag='!<arch>'#10;
  260.         ar_magic:array[1..length(armag)] of char=armag;}
  261. const   ar_magic:array[1..8] of char='!<arch>'#10;
  262.  
  263. begin
  264.     seq_no:=1;
  265.     Linker.AddLibraryFile(s+'.dll');
  266.     current_module^.linkofiles.insert(s+'.dll');
  267.     assign(out_file,s+'.ao2');
  268.     rewrite(out_file,1);
  269.     blockwrite(out_file,ar_magic,sizeof(ar_magic));
  270. en